
Namespace Result
    Public Class ExcelRsWriter
        Inherits RsWriter

        Public Sub New(ByVal Source As ADODB.Recordset, ByVal Target As String)
            MyBase.New(Source, Target)
        End Sub

        Public Overrides Function Execute() As Long
            Dim xls As Excel.Application
            Try
                xls = ExcelTools.CreateHiddenExcelApp()
            Catch ex As Exception
                xls = Nothing
                Throw ex
            End Try

            Dim wbks As Excel.Workbooks
            Dim wbk As Excel.Workbook
            wbks = CType(xls.Workbooks, Excel.Workbooks)
            Try
                If IO.File.Exists(Target) Then

                    wbk = CType(wbks.Open(Target, False, False, , , , False, , , , False), Excel.Workbook)
                Else
                    wbk = CType(wbks.Add(), Excel.Workbook)
                    wbk.SaveAs(Target)
                End If
            Catch ex As Exception
                xls.Quit()
                xls = Nothing
                Throw ex
            End Try

            wbks = Nothing
            Dim wkss As Excel.Worksheets = CType(wbk.Worksheets, Excel.Worksheets)
            Dim wks As Excel.Worksheet


            Dim xlsEx As Exception = Nothing
            Try
                wks = CType(wkss.Add, Excel.Worksheet)
                WriteHeader(wks)
                WriteContents(wks)
                wbk.Save()
            Catch ex As Exception
                xlsEx = ex
            End Try

            wks = Nothing
            wbk.Close(False)
            wbk = Nothing
            xls.Quit()
            xls = Nothing

            If Not xlsEx Is Nothing Then Throw xlsEx
        End Function

        Private Sub WriteHeader(ByVal wks As Excel.Worksheet)
            Dim cell As Excel.Range = CType(wks.Cells(1, 1), Excel.Range)
            For Each f As ADODB.Field In Source.Fields
                cell.Value = f.Name
                cell = CType(cell.Offset(, 1), Excel.Range)
            Next
            cell = Nothing
        End Sub


        Private Sub WriteContents(ByVal wks As Excel.Worksheet)
            Dim cell As Excel.Range = CType(wks.Cells(1, 1), Excel.Range)
            While Not Source.EOF
                cell = CType(cell.Offset(1, -CType(cell.Column, Int32) + 1), Excel.Range)

                For Each f As ADODB.Field In Source.Fields
                    cell.Value = f.Value
                    cell = CType(cell.Offset(0, 1), Excel.Range)
                Next
                Source.MoveNext()

                Threading.Thread.Sleep(1)
            End While
            cell = Nothing
        End Sub
    End Class
End Namespace
